home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / GS_DBFLD.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-27  |  50KB  |  1,482 lines
  1. {                      dBase III Field Handler
  2.  
  3.        GS_DBFLD Copyright (c)  Richard F. Griffin
  4.  
  5.        15 November 1990
  6.  
  7.        102 Molded Stone Pl
  8.        Warner Robins, GA  31088
  9.  
  10.        -------------------------------------------------------------
  11.        This unit handles field processing for all dBase III file (.DBF)
  12.        operations.
  13.  
  14.                    SHAREWARE  -- COMMERCIAL USE RESTRICTED
  15.  
  16.        Changes:
  17.  
  18.        02 May 91 - Changed the type of value returned for a date field from
  19.                    string to longint.  The value assigned is the julian date.
  20.                    Note that the Julian day number is not the same as the
  21.                    serial day number (1-366) which is sometimes (erroneously)
  22.                    called a Julian date.  Refer to the GS_Date unit for more
  23.                    information.
  24.  
  25.        03 May 91 - Ensured Date field is a julian date for .NDX indexes in the
  26.                    IndexTo method.
  27.  
  28.        02 Jun 91 - Allowed a 'blank' date field to be acccepted if the field
  29.                    was originally blank in AcceptField.
  30.  
  31.        31 Jul 91 - Created a StatusUpdate virtual method to allow a user to
  32.                    track progress of actions such as Pack and IndexTo.  The
  33.                    status will be passed to StatusUpdate from within those
  34.                    methods.  The basic StatusUpdate is empty and does nothing
  35.                    with the passed status.  The user has the option to create
  36.                    his own virtual method to capture this information.
  37.  
  38.        20 Oct 91 - Added a Zap method to delete and remove all records.
  39.  
  40.        20 Oct 91 - Corrected the Pack Method to write the EOF Mark in the
  41.                    proper location.
  42.  
  43.        11 Nov 91 - Corrected IndexTo problem with garbage object data.
  44.                    Added close and init calls to ensure good object.
  45.  
  46.        20 Feb 92 - Added a Done destructor to allow dynamic allocation
  47.                    of objects.
  48.  
  49.                    Added GSP_dBFld_Objct as pointer type to the object.
  50.                    This facilitates dynamic creation of the object.
  51.  
  52. ------------------------------------------------------------------------------}
  53. {
  54.                            ┌──────────────────────┐
  55.                            │  INTERFACE SECTION:  │
  56.                            └──────────────────────┘
  57. }
  58. unit GS_dBFld;
  59. {$D-}
  60.  
  61. interface
  62.  
  63. uses
  64.    CRT,
  65.    GS_Date,
  66.    GS_Edit,
  67.    GS_FileH,
  68.    GS_Error,
  69.    GS_KeyI,
  70.    GS_Strng,
  71.    GS_Winfc,
  72.    GS_dBase;
  73.  
  74. const
  75.    StatusStart     = -1;
  76.    StatusStop      = 0;
  77.    StatusIndexTo   = 1;
  78.    StatusPack      = 2;
  79.  
  80. type
  81.    GSP_dBFld_Objt = ^GS_dBFld_Objt;
  82.    GS_dBFld_Objt   = object(GS_dBase_dB)
  83.       LastFldTyp   : char;            {Last FieldGet type field}
  84.       LastFldDec   : integer;         {Last FieldGet Decimals}
  85.       LastFldLth   : integer;         {Last FieldGet Length}
  86.       LastFldNam   : string[11];      {Last FieldGet Name}
  87.       LastFldNum   : integer;         {Last FieldGet Number}
  88.       EditOn       : boolean;         {Edit allowed}
  89.       RecChanged   : boolean;         {Flag for record changed}
  90.       Memo_Loc     : longint;         {Starting memo block for field}
  91.       Memo_Bloks   : integer;         {Number of blocks used for the field}
  92.       Memo_Store   : GS_Edit_Objt;    {Object to store/edit memos}
  93.       DeleteOnF9   : boolean;         {Flag to permit F9 to delete/undelete}
  94.  
  95.       Constructor Init(FName : string);
  96.       Destructor Done;
  97.       Procedure Check_Func_Keys; virtual;
  98.       Function  Create(FName : string) : boolean;
  99.       function  DateGet(st : string) : longint;
  100.       function  DateGetN(n : integer) : longint;
  101.       Procedure DatePut(st : string; jdte : longint);
  102.       Procedure DatePutN(n : integer; jdte : longint);
  103.       Function  FieldAccept(st,Titl : string; x,y : integer) : string;
  104.       Procedure FieldDisplay(st,Titl : string; x,y : integer);
  105.       Function  FieldDisplayScreen : boolean;
  106.       Function  FieldGet(st : string) : string;
  107.       Function  FieldGetN(n : integer) : string;
  108.       Procedure FieldPut(st1, st2 : string);
  109.       Procedure FieldPutN(n : integer; st1 : string);
  110.       Function  FieldUpdateScreen : boolean;
  111.       Function  FieldAppendScreen(empty : boolean) : boolean;
  112.       Function  Formula(st : string; var ftyp : char) : string; virtual;
  113.       Function  HuntFieldName(st : string; var fs : integer) : boolean;
  114.       Procedure IndexTo(filname, formla : string);
  115.       function  LogicGet(st : string) : boolean;
  116.       function  LogicGetN(n : integer) : boolean;
  117.       Procedure LogicPut(st : string; b : boolean);
  118.       Procedure LogicPutN(n : integer; b : boolean);
  119.       Procedure MemoEdit;
  120.       function  MemoGetLine(linenum : integer) : string;
  121.       procedure MemoGet(rpt : string);
  122.       Procedure MemoWidth(l : integer);
  123.       function  MemoLines : integer;
  124.       function  MemoPut : string;
  125.       function  NumberGet(st : string) : real;
  126.       function  NumberGetN(n : integer) : real;
  127.       Procedure NumberPut(st : string; r : real);
  128.       Procedure NumberPutN(n : integer; r : real);
  129.       Procedure Pack;
  130.       Procedure StatusUpdate(statword1,statword2,statword3 : longint); virtual;
  131.       function  StringGet(st : string) : string;
  132.       function  StringGetN(n : integer) : string;
  133.       Procedure StringPut(st1, st2 : string);
  134.       Procedure StringPutN(n : integer; st1 : string);
  135.       Procedure Zap;
  136.    end;
  137.  
  138. implementation
  139.  
  140. constructor GS_dBFld_Objt.Init(FName : string);
  141. begin
  142.    EditOn := true;
  143.    GS_dBase_DB.Init(FName);
  144.    Memo_Store.Init;                   {Initialize the edit object}
  145.    Memo_Store.Edit_Lgth := 50;        {Set default memo line size to 50}
  146.    Wait_Cr := false;                  {Set EditString not to wait for CR}
  147.    DeleteOnF9 := false;               {Turn off F9 for delete/undelete}
  148. end;
  149.  
  150. destructor GS_dBFld_Objt.Done;
  151. begin
  152.    Memo_Store.Done;
  153.    GS_dBase_DB.UnInit;
  154. end;
  155.  
  156. procedure GS_dBFld_Objt.Check_Func_Keys;
  157. begin
  158.    case ch of
  159.      Kbd_F9   : begin
  160.                    if DeleteOnF9 then
  161.                    begin
  162.                       if RecNumber < 0 then
  163.                       begin
  164.                          if DelFlag then CurRecord^[0] :=  32
  165.                             else CurRecord^[0] := 42;
  166.                          DelFlag := not DelFlag;
  167.                       end
  168.                          else if DelFlag then UnDelete else Delete;
  169.                       GS_KeyI_Ret := true;
  170.                       Ch := Kbd_Ret;
  171.                    end else GS_dBase_DB.Check_Func_Keys;
  172.                 end;
  173.      Kbd_F10  : begin
  174.                    GS_KeyI_Ret := true;
  175.                    Ch := Kbd_Ret;
  176.                 end;
  177.      else GS_dBase_DB.Check_Func_Keys;
  178.   end;
  179. end;
  180.  
  181.  
  182. function  GS_dBFld_Objt.DateGet(st : string) : longint;
  183. var
  184.    t     : string;
  185.    v     : longint;
  186. begin
  187.    t := FieldGet(st);
  188.    v := GS_Date_Juln(t);
  189.    if v > 0 then DateGet := v else DateGet := 0;
  190. end;
  191.  
  192. function  GS_dBFld_Objt.DateGetN(n : integer) : longint;
  193. var
  194.    t     : string;
  195.    v     : longint;
  196. begin
  197.    t := FieldGetN(n);
  198.    v := GS_Date_Juln(t);
  199.    if v > 0 then DateGetN := v else DateGetN := 0;
  200. end;
  201.  
  202. Procedure GS_dBFld_Objt.DatePut(st : string; jdte : longint);
  203. var
  204.    f    : integer;
  205.    t    : string[8];
  206. begin
  207.    if not HuntFieldName(st,f) then
  208.    begin
  209.       ShowError(625,st);
  210.       exit;
  211.    end;
  212.    if jdte = 0 then t := '        '
  213.       else t := GS_Date_DBStor(jdte);
  214.    FieldPutN(f,t);
  215. end;
  216.  
  217. Procedure GS_dBFld_Objt.DatePutN(n : integer; jdte : longint);
  218. var
  219.    t    : string[8];
  220. begin
  221.    if n > NumFields then
  222.    begin
  223.       ShowError(627,'Field number out of range');
  224.       exit;
  225.    end;
  226.    if jdte = 0 then t := '        '
  227.       else t := GS_Date_DBStor(jdte);
  228.    FieldPutN(n,t);
  229. end;
  230.  
  231. function  GS_dBFld_Objt.LogicGet(st : string) : boolean;
  232. begin
  233.    LogicGet := ValLogic(FieldGet(st));
  234. end;
  235.  
  236. function  GS_dBFld_Objt.LogicGetN(n : integer) : boolean;
  237. begin
  238.    LogicGetN := ValLogic(FieldGetN(n));
  239. end;
  240.  
  241. Procedure GS_